home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / CODE / views / pop-up-view.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  7.2 KB  |  219 lines  |  [TEXT/CCL2]
  1. ;;; pop-up-view.lisp
  2. ;;;
  3. ;;; Paul McCartney, Spring 1992
  4. ;;;
  5. ;;; Copyright © 1992 Paul McCartney.  All Rights Reserved.
  6. ;;; 
  7. ;;; Washington University Medical Informatics Training Program
  8. ;;;
  9. ;;; DESCRIPTION:
  10. ;;;
  11. ;;; Pop up views are used to temporarily display graphical/textual information
  12. ;;; to the user.  When the user clicks on an area and keeps the mouse button
  13. ;;; down, a view that appears like a shadow edged window is shown.  Anything can
  14. ;;; be drawn to the pop up view at that point.  When the user releases the mouse
  15. ;;; button, the background is restored instantaneously.
  16. ;;;
  17. ;;; USE:
  18. ;;;
  19. ;;; pop-up-view  -  object class (not a view).  DO NOT INSTALL THIS AS A VIEW.
  20. ;;;   :pop-up-view-size    - size of pop up view
  21. ;;;   :pop-up-view-draw-fn - function to be called to draw things to the
  22. ;;;                          pop up view; takes pop up view, view size, and
  23. ;;;                          data as arguments
  24. ;;;   :color-list          - list including:
  25. ;;;                            :background
  26. ;;;                            :foreground
  27. ;;;                            :frame  - border outline color
  28. ;;;                            :shadow
  29. ;;;
  30. ;;; puv-init  - initialize this module.  YOU MUST CALL THIS INIT TO USE POP UP VIEWS.
  31. ;;; puv-destroy - free up module data
  32. ;;; puv-display - this function should be called in response to a mouse click
  33. ;;;               event.  The pop up view is shown and will continue to be shown
  34. ;;;               as long as the mouse button is down.
  35. ;;;
  36. ;;; HISTORY:
  37. ;;;
  38. ;;; 7/18/92 Created. -PM
  39.  
  40. (in-package :ccl)
  41. (use-package :oou)
  42.  
  43. (require :GWorld-view)
  44.  
  45. (export '(puv-init puv-destroy puv-display pop-up-view)
  46.         :ccl)
  47.  
  48.  
  49. (defvar *puv-info*)
  50.  
  51.  
  52. (defstruct puv-store 
  53.   offscreen-storage
  54.   onscreen-view
  55.   onscreen-rect
  56.   offscreen-rect)
  57.  
  58.  
  59. (defclass pop-up-view ()
  60.   ((size :initarg :pop-up-view-size :accessor size)
  61.    (draw-fn :initarg :pop-up-view-draw-fn :accessor draw-fn)
  62.    (color-list :initarg :color-list :accessor color-list)
  63.    )
  64.   (:default-initargs
  65.     :pop-up-view-size #@(50 50)
  66.     :pop-up-view-draw-fn #'(lambda (view size data) (declare (ignore view size data)))
  67.     :color-list ()
  68.     )
  69. )
  70.  
  71.  
  72. (defun puv-init (&optional (size #@(200 200)))
  73.   (let ((GWorld (make-instance 'GWorld-view
  74.                   :GW-depth 0
  75.                   :view-size size)))
  76.     (GW-alloc GWorld)
  77.     (setf *puv-info*
  78.           (make-puv-store
  79.            :offscreen-storage GWorld
  80.            :onscreen-view (make-instance 'view)
  81.            :onscreen-rect (make-record :rect)
  82.            :offscreen-rect (make-record :rect))) ))
  83.  
  84.  
  85. (defun puv-destroy ()
  86.   (GW-free (puv-store-offscreen-storage *puv-info*))
  87.   (dispose-record (puv-store-onscreen-rect *puv-info*))
  88.   (dispose-record (puv-store-offscreen-rect *puv-info*)))
  89.   
  90.  
  91. (defun copy-background-offscreen (view size)
  92.   (let* ((pop-up-view (puv-store-onscreen-view *puv-info*))
  93.          (r1 (puv-store-onscreen-rect *puv-info*))
  94.          (r2 (puv-store-offscreen-rect *puv-info*))
  95.          (GWorld (puv-store-offscreen-storage *puv-info*))
  96.          (view-topleft (view-scroll-position view))
  97.          (view-bottomright (add-points view-topleft (view-size view)))
  98.          (mouse (view-mouse-position view))
  99.          (top (max (point-v view-topleft) 
  100.                    (min (point-v mouse) (- (point-v view-bottomright) (point-v size)))))
  101.          (left (max (point-h view-topleft)
  102.                     (min (point-h mouse) (- (point-h view-bottomright) (point-h size)))))
  103.          (topleft (make-point left top))
  104.          (bottomright (add-points topleft size)))    
  105.     (rset r1 :rect.topleft topleft)
  106.     (rset r1 :rect.bottomright bottomright)
  107.     (rset r2 :rect.topleft #@(0 0))
  108.     (rset r2 :rect.bottomright (subtract-points bottomright topleft))
  109.     (with-locked-GWorld-view GWorld
  110.       (with-focused-view view
  111.         (with-fore-color *black-color*
  112.           (with-back-color *white-color*
  113.             (with-pointers ((sb (rref (wptr view) :GrafPort.portBits))
  114.                             (db (rref (wptr GWorld) :GrafPort.portBits)))
  115.               (#_CopyBits sb db r1 r2 #$srcCopy (%null-ptr))) ))))
  116.     (add-subviews view pop-up-view)
  117.     (set-view-size pop-up-view size)
  118.     (set-view-position pop-up-view topleft) ))
  119.  
  120.  
  121. (defun restore-background (view)
  122.   (let ((pop-up-view (puv-store-onscreen-view *puv-info*))
  123.         (r1 (puv-store-onscreen-rect *puv-info*))
  124.         (r2 (puv-store-offscreen-rect *puv-info*))
  125.         (GWorld (puv-store-offscreen-storage *puv-info*)))
  126.     (remove-subviews view pop-up-view)
  127.     (with-locked-GWorld-view GWorld
  128.       (with-focused-view view
  129.         (with-fore-color *black-color*
  130.           (with-back-color *white-color*
  131.             (with-pointers ((sb (rref (wptr GWorld) :GrafPort.portBits))
  132.                             (db (rref (wptr view) :GrafPort.portBits)))
  133.               (#_CopyBits sb db r2 r1 #$srcCopy (%null-ptr)))
  134.             (validate-view view)))))))
  135.   
  136.  
  137. ;;;;
  138. ;;;; POP UP VIEW METHODS
  139. ;;;;
  140.  
  141. (defmethod part-color ((puv pop-up-view) part)
  142.   (getf (color-list puv) part))
  143.  
  144.  
  145. (defmethod puv-display ((puv pop-up-view) parent-view &optional (data nil))
  146.   (let* ((pop-up-view (puv-store-onscreen-view *puv-info*))
  147.          (window-view (view-window parent-view)))
  148.     (copy-background-offscreen window-view (size puv))
  149.     (puv-draw puv pop-up-view data)
  150.     (do () ((not (mouse-down-p))))
  151.     (restore-background window-view) ))
  152.  
  153.  
  154. (defmethod puv-draw ((puv pop-up-view) view data)
  155.   (let* ((back-topleft #@(2 2))
  156.          (back-bottomright (size puv))
  157.          (front-topleft #@(0 0))
  158.          (front-bottomright (subtract-points (size puv) #@(2 2)))
  159.          (right (point-h (size puv)))
  160.          (bottom (point-v (size puv))))
  161.     (with-GWorld-no-colorization (view 0 0 right bottom #$srcCopy)
  162.       (with-back-color (or (part-color puv :background) *white-color*)
  163.         (with-fore-color (or (part-color puv :shadow) *black-color*)
  164.           (rlet ((r :rect :topleft back-topleft :bottomright back-bottomright))
  165.             (#_PaintRect r)))
  166.         (rlet ((r :rect :topleft front-topleft :bottomright front-bottomright))
  167.           (#_EraseRect r)
  168.           (with-fore-color (or (part-color puv :frame) *black-color*)
  169.             (#_FrameRect r))
  170.           (with-fore-color (or (part-color puv :foreground) *black-color*)
  171.             (funcall (draw-fn puv) *GW-offscreen-view* (size puv) data))))) ))
  172.  
  173.  
  174. (provide :pop-up-view)
  175.  
  176.              
  177. #|
  178. ; Example
  179.  
  180. (require :quickdraw)
  181.  
  182. (puv-init)
  183. ;(puv-destroy)
  184.  
  185. (defclass foo-window (window)
  186.   ()
  187.   (:default-initargs
  188.     :view-size #@(300 300)
  189.     :color-p t
  190.   )
  191. )
  192.  
  193. (defun draw-a-circle (view size data)
  194.   (declare (ignore size data))
  195.   (with-fore-color *red-color*
  196.     (paint-oval view #@(20 20) #@(50 50)) ))
  197.  
  198. (defvar *color-puv* 
  199.   (make-instance 'pop-up-view
  200.     :pop-up-view-size #@(100 100)
  201.     :pop-up-view-draw-fn #'draw-a-circle
  202.     :color-list (list :background *yellow-color*
  203.                       :frame *light-blue-color*
  204.                       :shadow *blue-color*)))
  205.  
  206. (defmethod view-draw-contents ((view foo-window))
  207.   (dotimes (i 60)
  208.     (with-fore-color (random most-positive-fixnum)
  209.       (move-to view 10 (+ 20 (* i 2)))
  210.       (line-to view 100 (+ 20 (* i 4)))))
  211.   (move-to view 10 20)
  212.   (format view "Click here.") )
  213.  
  214. (defmethod view-click-event-handler ((view foo-window) where)
  215.   (puv-display *color-puv* view))
  216.   
  217. (setf w (make-instance 'foo-window))
  218. |#
  219.